# $Id: login.tcl 1681 2009-02-23 13:56:14Z sergei $

package require xmpp::dns
package require xmpp::auth

if {[catch {package require xmpp::starttls}]} {
    set use_tls 0
} else {
    set use_tls 1
}

if {[catch {package require xmpp::compress}]} {
    set have_compress 0
} else {
    set have_compress 1
}

if {[catch {package require xmpp::sasl}]} {
    set have_sasl 0
} else {
    set have_sasl 1
}

set have_proxy 0
if {![catch {package require pconnect::socks4}]} {
    set have_proxy 1
}
if {![catch {package require pconnect::socks5}]} {
    set have_proxy 1
}
if {![catch {package require pconnect::https}]} {
    set have_proxy 1
}

if {[catch {package require xmpp::transport::poll}]} {
    set have_http_poll 0
} else {
    set have_http_poll 1
}

custom::defgroup Warnings [::msgcat::mc "Warning display options."] \
    -group Tkabber

if {$use_tls} {
    custom::defvar tls_warnings 1 [::msgcat::mc "Display SSL warnings."] \
	-group Warnings -type boolean
}

custom::defgroup Login \
    [::msgcat::mc "Login options."] \
    -group Tkabber

custom::defvar loginconf(user) "" \
    [::msgcat::mc "User name."] \
    -group Login -type string
custom::defvar loginconf(server) "localhost" \
    [::msgcat::mc "Server name."] \
    -group Login -type string
custom::defvar loginconf(password) "" \
    [::msgcat::mc "Password."] \
    -group Login -type password
custom::defvar loginconf(resource) "tkabber" \
    [::msgcat::mc "Resource."] \
    -group Login -type string
custom::defvar loginconf(priority) "8" \
    [::msgcat::mc "Priority."] \
    -group Login -type integer

custom::defvar loginconf(connect_forever) 0 \
    [::msgcat::mc "Retry to connect forever."] \
    -group Login -type boolean

custom::defvar loginconf(allowauthplain) 0 \
    [::msgcat::mc "Allow plaintext authentication mechanisms (when password\
		   is transmitted unencrypted)."] \
	-group Login -type boolean

custom::defvar loginconf(allowgoogletoken) 1 \
    [::msgcat::mc "Allow X-GOOGLE-TOKEN authentication mechanisms. It requires\
		   connection to Google via HTTPS."] \
	-group Login -type boolean

if {$have_sasl} {
    custom::defvar loginconf(usesasl) 1 \
	[::msgcat::mc "Use SASL authentication."] \
	-group Login -type boolean
}

set values [list plaintext [::msgcat::mc "Plaintext"]]
if {$have_compress} {
    lappend values compressed [::msgcat::mc "Compression"]
}
if {$use_tls} {
    lappend values encrypted [::msgcat::mc "Encryption (STARTTLS)"] \
		   ssl       [::msgcat::mc "Encryption (legacy SSL)"]
}

if {$use_tls || $have_compress} {
    custom::defvar loginconf(stream_options) plaintext \
	[::msgcat::mc "XMPP stream options when connecting to server."] \
	-group Login -type options \
	-values $values
}

if {$use_tls} {
    custom::defvar loginconf(sslcertfile) "" \
	[::msgcat::mc "SSL certificate file (optional)."] \
	-group Login -type file
    custom::defvar loginconf(sslcacertstore) "" \
	[::msgcat::mc "SSL certification authority file or directory (optional)."] \
	-group Login -type file
    custom::defvar loginconf(sslkeyfile) "" \
	[::msgcat::mc "SSL private key file (optional)."] \
	-group Login -type file
}

if {$have_proxy} {
    set values [list none [::msgcat::mc "None"]]
    if {![catch {package present pconnect::https}]} {
	lappend values https [::msgcat::mc "HTTPS"]
    }
    if {![catch {package present pconnect::socks4}]} {
	lappend values socks4 [::msgcat::mc "SOCKS4a"]
    }
    if {![catch {package present pconnect::socks5}]} {
	lappend values socks5 [::msgcat::mc "SOCKS5"]
    }
    custom::defvar loginconf(proxy) none \
	[::msgcat::mc "Proxy type to connect."] \
	-group Login -type options \
	-values $values
    custom::defvar loginconf(proxyhost) "localhost" \
	[::msgcat::mc "HTTP proxy address."] \
	-group Login -type string
    custom::defvar loginconf(proxyport) 3128 \
	[::msgcat::mc "HTTP proxy port."] \
	-group Login -type integer
    custom::defvar loginconf(proxyusername) "" \
	[::msgcat::mc "HTTP proxy username."] \
	-group Login -type string
    custom::defvar loginconf(proxypassword) "" \
	[::msgcat::mc "HTTP proxy password."] \
	-group Login -type password
    custom::defvar loginconf(proxyuseragent) \
	"Mozilla/4.0 (compatible; MSIE 6.0;\
	 $::tcl_platform(os) $::tcl_platform(osVersion))" \
	[::msgcat::mc "User-Agent string."] \
	-group Login -type string
}

custom::defvar loginconf(usealtserver) 0 \
    [::msgcat::mc "Use explicitly-specified server address and port."] \
    -group Login -type boolean
custom::defvar loginconf(altserver) "" \
    [::msgcat::mc "Server name or IP-address."] \
    -group Login -type string
custom::defvar loginconf(altport) "5222" \
    [::msgcat::mc "Server port."] \
    -group Login -type integer

custom::defvar loginconf(replace_opened) 1 \
    [::msgcat::mc "Replace opened connections."] \
    -group Login -type boolean

if {$have_http_poll} {
    custom::defvar loginconf(usehttppoll) 0 \
	[::msgcat::mc "Use HTTP poll connection method."] \
	-group Login -type boolean
    custom::defvar loginconf(pollurl) "" \
	[::msgcat::mc "URL to connect to."] \
	-group Login -type string
    custom::defvar loginconf(usepollkeys) 1 \
	[::msgcat::mc "Use HTTP poll client security keys (recommended)."] \
	-group Login -type boolean
    custom::defvar loginconf(numberofpollkeys) 100 \
	[::msgcat::mc "Number of HTTP poll client security keys to send\
		       before creating new key sequence."] \
	-group Login -type integer
    custom::defvar loginconf(polltimeout) 0 \
	[::msgcat::mc "Timeout for waiting for HTTP poll responses (if set\
		       to zero, Tkabber will wait forever)."] \
	-group Login -type integer
    custom::defvar loginconf(pollmin) 6000 \
	[::msgcat::mc "Minimum poll interval."] \
	-group Login -type integer
    custom::defvar loginconf(pollmax) 60000 \
	[::msgcat::mc "Maximum poll interval."] \
	-group Login -type integer
}

custom::defvar reasonlist {} [::msgcat::mc "List of logout reasons."] \
	-group Hidden

######################################################################

# connect errors mapping

array set connect_error [list \
	err_unknown 			[::msgcat::mc "Unknown error"] \
	timeout				[::msgcat::mc "Timeout"] \
	network-failure			[::msgcat::mc "Network failure"] \
	err_authorization_required	[::msgcat::mc "Proxy authentication required"] \
	err_version			[::msgcat::mc "Incorrect SOCKS version"] \
	err_unsupported_method		[::msgcat::mc "Unsupported SOCKS method"] \
	err_authentication_unsupported	[::msgcat::mc "Unsupported SOCKS authentication method"] \
	err_authorization		[::msgcat::mc "SOCKS authentication failed"] \
	rsp_failure			[::msgcat::mc "SOCKS request failed"] \
	rsp_errconnect			[::msgcat::mc "SOCKS server cannot identify username"] \
	rsp_erruserid			[::msgcat::mc "SOCKS server username identification failed"] \
	rsp_notallowed			[::msgcat::mc "SOCKS connection not allowed by ruleset"] \
	rsp_netunreachable		[::msgcat::mc "Network unreachable"] \
	rsp_hostunreachable		[::msgcat::mc "Host unreachable"] \
	rsp_refused			[::msgcat::mc "Connection refused by destination host"] \
	rsp_expired			[::msgcat::mc "TTL expired"] \
	rsp_cmdunsupported		[::msgcat::mc "SOCKS command not supported"] \
	rsp_addrunsupported		[::msgcat::mc "Address type not supported by SOCKS proxy"] \
	err_unknown_address_type	[::msgcat::mc "Unknown address type"]]

# TLS info
#
# [::msgcat::mc "Certificate has expired"]
# [::msgcat::mc "Self signed certificate"]

######################################################################

if {![info exists connections]} {
    set connections {}
}

proc connections {{all 0}} {
    global connections

    set res {}
    foreach c $connections {
	if {$all || [lindex $c 1]} {
	    lappend res [lindex $c 0]
	}
    }
    return $res
}

proc add_to_connection {active xlib} {
    global connections

    set idx [lsearch -exact $connections [list $xlib 0]]
    set connections [lreplace $connections $idx $idx]
    set idx [lsearch -exact $connections [list $xlib 1]]
    set connections [lreplace $connections $idx $idx]
    lappend connections [list $xlib $active]
}

hook::add connected_hook [list add_to_connection 1] 1

proc remove_from_connection {xlib} {
    global connections

    set idx [lsearch -exact $connections [list $xlib 0]]
    set connections [lreplace $connections $idx $idx]
    set idx [lsearch -exact $connections [list $xlib 1]]
    set connections [lreplace $connections $idx $idx]
}

hook::add disconnected_hook remove_from_connection 1

proc connection_jid {xlib} {
    global connjid
    return $connjid($xlib)
}

proc connection_bare_jid {xlib} {
    global connjid
    return [::xmpp::jid::stripResource $connjid($xlib)]
}

proc connection_user {xlib} {
    global connjid
    return [::xmpp::jid::node $connjid($xlib)]
}

proc connection_server {xlib} {
    global connjid
    return [::xmpp::jid::server $connjid($xlib)]
}

proc connection_resource {xlib} {
    global connjid
    return [::xmpp::jid::resource $connjid($xlib)]
}

proc connection_requested_jid {xlib} {
    global connrjid
    return $connrjid($xlib)
}

proc connection_requested_user {xlib} {
    global connrjid
    return [::xmpp::jid::node $connrjid($xlib)]
}

proc connection_requested_server {xlib} {
    global connrjid
    return [::xmpp::jid::server $connrjid($xlib)]
}

proc connection_requested_resource {xlib} {
    global connrjid
    return [::xmpp::jid::resource $connrjid($xlib)]
}

######################################################################

proc login {logindata} {
    global connect_error
    global login_after_time
    global login_after_id

    array set lc $logindata

    set jid [::xmpp::jid::normalize [::xmpp::jid::jid $lc(user) \
						      $lc(server) \
						      $lc(resource)]]
    if {[info exists login_after_id($jid)]} {
	after cancel $login_after_id($jid)
	unset login_after_id($jid)
    }

    debugmsg login "Starting login"
    set_status [::msgcat::mc "Connecting to %s" $lc(server)]
    if {[catch {login_connect $logindata} xlib] > 0} {
	# Nasty thing has happened.
	# $xlib contains error message here.
	debugmsg login "Failed to connect: $xlib"
	if {$lc(connect_forever)} {
	    login_retry $logindata
	} else {
	    if {[winfo exists .connect_err]} {
		destroy .connect_err
	    }
	    if {[info exists connect_error($xlib)]} {
		set msg $connect_error($xlib)
	    } else {
		set msg $xlib
	    }
	    set res [MessageDlg .connect_err -width 600 -icon error \
		-message [::msgcat::mc "Failed to connect: %s" $msg] \
		-type user -buttons [list abort [::msgcat::mc "Keep trying"]] \
		-default 0 -cancel 0]
	    if {$res} {
		set lc(connect_forever) 1
		set logindata [array get lc]
		login_retry $logindata
	    }
	}
	return
    }
    # OK, connected.
    add_to_connection 0 $xlib
    debugmsg login "Connect successful ($jid) $xlib"
    set login_after_time 7500
    login_login $xlib $logindata
}

proc login_retry {logindata} {
    global login_after_time
    global login_after_id

    if {![info exists login_after_time]} {
	set login_after_time 7500
    }
    if {$login_after_time < 1800000} {
	# 1800000 == 30 * 60 * 1000 == 30min
	# the sequence goes: 15s, 30s, 1min, 2min, 4min, 8min, 16min, 32min, 32min...
	set login_after_time [expr {$login_after_time * 2}]
    }
    array set lc $logindata

    set jid [::xmpp::jid::normalize [::xmpp::jid::jid $lc(user) \
						      $lc(server) \
						      $lc(resource)]]
    debugmsg login "Scheduling connect retry for $jid in ${login_after_time}ms"
    if {[info exists login_after_id($jid)]} {
	after cancel $login_after_id($jid)
	unset login_after_id($jid)
    }
    login_retry1 $login_after_time $jid $logindata
}

proc login_retry1 {interval jid logindata} {
    global login_after_id

    incr interval -1000

    if {$interval <= 0} {
	login $logindata
    } else {
	set login_after_id($jid) [after 1000 [list login_retry1 $interval $jid $logindata]]
	set_status [::msgcat::mc "Login retry for %s in %s" $jid \
				 [format_time [expr {$interval/1000}]]]
    }
}

proc client:tls_callback {xlib args} {
    global tls_result tls_warnings
    global ssl_certificate_fields
    global tls_warning_info

    switch -- [lindex $args 0] {
	info {
	    set_status [lindex $args 4]
	}

	verify {
	    if {[cequal [set reason [lindex $args 5]] ""]} {
		return 1
	    }
	    set info [::msgcat::mc [string totitle $reason 0 0]]
	    append tls_warning_info($xlib) "$info\n"
	    if {!$tls_warnings} {
		return 1
	    }
	    append info [::msgcat::mc ". Proceed?\n\n"]
	    foreach {k v} [lindex $args 3] {
		switch -- $k {
		    subject - issuer {
			set v [regsub -all {\s*[/,]\s*(\w+=)} $v \n\t\\1]
		    }
		}
		if {![cequal $v ""]} {
		    if {[info exists ssl_certificate_fields($k)]} {
			append info [format "%s: %s\n" \
					    $ssl_certificate_fields($k) $v]
		    } else {
			append info [format "%s: %s\n" $k $v]
		    }
		}
	    }

	    set blocking [fconfigure [set fd [lindex $args 1]] -blocking]
	    fconfigure $fd -blocking 1
	    set readable [fileevent $fd readable]
	    fileevent $fd readable {}

	    set res [MessageDlg .tls_callback -aspect 50000 -icon warning \
			        -type user -buttons {yes no} -default 1 \
			        -cancel 1 \
			        -message [string trim $info]]

	    fileevent $fd readable $readable
	    fconfigure $fd -blocking $blocking

	    if {$res} {
		set res 0
	    } else {
		set res 1
	    }
	    return $res
	}

	error {
	    set tls_result [join [lrange $args 2 end] " "]
	}

	default {
	}
    }
}

proc create_xlib {jid} {
    global connhist connrjid connjid

    set njid [::xmpp::jid::normalize $jid]
    if {[info exists connhist($njid)]} {
	if {[lsearch -exact [connections] $connhist($njid)] < 0} {
	    set xlib $connhist($njid)
	} else {
	    set xlib [::xmpp::new -messagecommand    client:message    \
				  -presencecommand   client:presence   \
				  -iqcommand         client:iq         \
				  -disconnectcommand client:disconnect \
				  -statuscommand     client:status     \
				  -errorcommand      client:error      \
				  -logcommand        client:log]
	}
    } else {
	set xlib [::xmpp::new -messagecommand    client:message    \
			      -presencecommand   client:presence   \
			      -iqcommand         client:iq         \
			      -disconnectcommand client:disconnect \
			      -statuscommand     client:status     \
			      -errorcommand      client:error      \
			      -logcommand        client:log]
	set connhist($njid) $xlib
    }

    set connrjid($xlib) $jid
    set connjid($xlib) $jid

    disco::new $xlib

    return $xlib
}

proc login_connect {logindata} {
    global use_tls have_compress have_sasl have_http_poll have_proxy
    global tls_warning_info
    global reconnect

    array set lc $logindata

    set jid [::xmpp::jid::jid $lc(user) \
			      $lc(server) \
			      $lc(resource)]

    set xlib [create_xlib $jid]

    set tls_warning_info($xlib) ""
    set reconnect($xlib) true

    set ascii_server [idna::domain_toascii $lc(server)]

    set args {}

    if {$have_proxy} {
	if {($lc(proxy) != "none")} {
	    lappend args -proxy     $lc(proxy)
	    lappend args -host      $lc(proxyhost)
	    lappend args -port      $lc(proxyport)
	    lappend args -username  $lc(proxyusername)
	    lappend args -password  $lc(proxypassword)
	    lappend args -useragent $lc(proxyuseragent)
	} else {
	    lappend args -proxy ""
	}
    }

    if {$have_http_poll && $lc(usehttppoll)} {
	if {$lc(pollurl) != ""} {
	    set url $lc(pollurl)
	} else {
	    if {[catch {::xmpp::dns::resolveHTTPPoll $ascii_server} urls]} {
		set urls {}
	    }
	    if {[llength $urls] == 0} {
		set url ""
	    } else {
		set url [lindex $urls 0]
	    }
	}

	# TODO: Asynchronous connect
	eval [list ::xmpp::connect $xlib \
				   -transport poll \
				   -timeout   $lc(polltimeout) \
				   -int       $lc(pollmin) \
				   -min       $lc(pollmin) \
				   -max       $lc(pollmax) \
				   -url       $url \
				   -usekeys   $lc(usepollkeys) \
				   -numkeys   $lc(numberofpollkeys)] \
				   $args

	return $xlib
    } else {
	if {$lc(usealtserver)} {
	    set hosts {}
	} else {
	    if {[catch {::xmpp::dns::resolveXMPPClient $ascii_server} hosts]} {
		set hosts {}
	    }
	    if {[llength $hosts] == 0} {
		set hosts [list [list $ascii_server 5222]]
	    }
	}
	set transport tcp
	if {$use_tls && $lc(stream_options) == "ssl"} {
	    set transport tls
	    # Do some heuristic.
	    # Traditionally legacy SSL port is 5223,
	    # so let's add 1 to all ports from SRV reply
	    set hosts1 {}
	    foreach hp $hosts {
		lassign $hp host port
		lappend hosts1 [list $host [incr port]]
	    }
	    set hosts $hosts1
	    lappend args -certfile      $lc(sslcertfile) \
			 -castore       $lc(sslcacertstore) \
			 -keyfile       $lc(sslkeyfile) \
			 -verifycommand [list client:tls_callback $xlib] \
			 -infocommand   [list update_tls_info $xlib]
	}

	if {$lc(usealtserver)} {
	    set hosts [list [list [idna::domain_toascii $lc(altserver)] \
			    $lc(altport)]]
	}

	# TODO: Asynchronous connect
	foreach hp $hosts {
	    lassign $hp host port

	    set code \
		[catch {
		    eval [list ::xmpp::connect $xlib $host $port \
					       -transport $transport] \
					       $args
		 } msg]
	    set info $::errorInfo

	    if {!$code} {
		return $xlib
	    }
	}

	return -code $code -errorinfo $info $msg
    }
}

########################################################################

proc login_login {xlib logindata} {
    global use_tls have_compress have_sasl
    global loginconf_hist
    global gr_nick gr_server gra_server

    set loginconf_hist($xlib) $logindata

    array set lc $logindata

    set gr_nick $lc(user)
    set gr_server conference.$lc(server)
    set gra_server conference.$lc(server)

    if {($use_tls && $lc(stream_options) == "encrypted") || \
	    ($have_compress && $lc(stream_options) == "compressed") || \
	    ($have_sasl && $lc(usesasl))} {
	::xmpp::openStream $xlib $lc(server) \
			   -version 1.0 \
			   -command [list login_login1 $xlib $logindata]
    } else {
	::xmpp::openStream $xlib $lc(server) \
			   -command [list login_login1 $xlib $logindata]
    }
}

proc login_login1 {xlib logindata status sessionid} {
    global use_tls have_compress

    if {$status != "ok"} {
	recv_auth_result $xlib $logindata $status $sessionid
	return
    }

    array set lc $logindata

    if {$use_tls && $lc(stream_options) == "encrypted"} {
	::xmpp::starttls::starttls $xlib \
			-command       [list login_login2 $xlib $logindata] \
			-certfile      $lc(sslcertfile) \
			-castore       $lc(sslcacertstore) \
			-keyfile       $lc(sslkeyfile) \
			-verifycommand [list client:tls_callback $xlib] \
			-infocommand   [list update_tls_info $xlib]
    } elseif {$have_compress && $lc(stream_options) == "compressed"} {
	::xmpp::compress::compress $xlib \
			-command     [list login_login2 $xlib $logindata]
    } else {
	login_login2 $xlib $logindata $status $sessionid
    }
}

proc login_login2 {xlib logindata status sessionid} {
    global have_sasl

    if {$status != "ok"} {
	recv_auth_result $xlib $logindata $status $sessionid
	return
    }

    array set lc $logindata

    if {$lc(allowauthplain)} {
	set digest auto
    } else {
	set digest true
    }

    if {$lc(allowgoogletoken)} {
	set disable {}
    } else {
	set disable {X-GOOGLE-TOKEN}
    }

    if {$have_sasl && $lc(usesasl)} {
	# SASL authentication
        ::xmpp::sasl::auth $xlib -username $lc(user) \
                                 -password $lc(password) \
                                 -resource $lc(resource) \
				 -digest   $digest \
				 -disable  $disable \
				 -command  [list recv_auth_result $xlib \
								 $logindata]
    } else {
	# Non-SASL authentication
        ::xmpp::auth::auth $xlib -sessionid $sessionid \
                                 -username  $lc(user) \
                                 -password  $lc(password) \
                                 -resource  $lc(resource) \
				 -digest    $digest \
				 -command [list recv_auth_result $xlib \
								 $logindata]
    }
}

########################################################################

proc logout {{xlib {}}} {
    global login_after_id

    debugmsg login "LOGOUT $xlib"

    if {$xlib == {}} {
	foreach jid [array names login_after_id] {
	    after cancel $login_after_id($jid)
	    unset login_after_id($jid)
	}

	foreach xlib [connections 1] {
	    disconnected $xlib
	}
    } else {
	disconnected $xlib
    }
}

proc client:disconnect {xlib} {
    global reconnect
    global loginconf_hist


    if {$reconnect($xlib)} {
	debugmsg login "RECONNECT $xlib"
    } else {
	debugmsg login "DISCONNECT $xlib"
    }

    disconnected $xlib

    if {$reconnect($xlib)} {
	after 1000 [list login $loginconf_hist($xlib)]
    }
}

proc connected {xlib logindata} {
    hook::run connected_hook $xlib
}

# TODO
proc disconnected {xlib} {
    remove_from_login_after_id $xlib

    if {[lsearch -exact [connections] $xlib] < 0} {
	::xmpp::disconnect $xlib
	return
    }

    hook::run disconnected_hook $xlib
}

hook::add disconnected_hook ::xmpp::disconnect 10

proc client:log {xlib dir type msg} {
    hook::run log_hook $xlib $dir $type $msg
}

proc remove_from_login_after_id {xlib} {
    global login_after_id

    set jid [::xmpp::jid::normalize [connection_requested_jid $xlib]]
    if {[info exists login_after_id($jid)]} {
	after cancel $login_after_id($jid)
	unset login_after_id($jid)
    }
}

proc recv_auth_result {xlib logindata res xml} {
    global connjid

    array set lc $logindata

    if {$res == "ok"} {
	set connjid($xlib) $xml
	connected $xlib $logindata
    } else {
	lassign [error_type_condition $xml] type cond
	if {($type == "sasl") || ($type == "auth" && $cond == "not-authorized")} {
	    set res [MessageDlg [epath] -aspect 50000 -icon error \
			 -message [::msgcat::mc "Authentication failed:\
						 %s\nCreate new account?" \
						[error_to_string $xml]] \
			 -type user -buttons {yes no} -default 0 -cancel 1]
	    if {!$res} {
		::xmpp::sendIQ $xlib set \
		    -query [::xmpp::xml::create query \
				-xmlns jabber:iq:register \
				-subelement [::xmpp::xml::create username \
						    -cdata $lc(user)] \
				-subelement [::xmpp::xml::create password \
						    -cdata $lc(password)]] \
		    -to $lc(server) \
		    -command [list recv_register_result $xlib $logindata]
		return
	    }
	} else {
	    MessageDlg [epath] -aspect 50000 -icon error \
		-message [::msgcat::mc "Authentication failed: %s" \
				       [error_to_string $xml]] \
		-type user -buttons {ok} -default 0 -cancel 0
	}

	logout $xlib
    }
}

proc recv_register_result {xlib logindata res xml} {
    logout $xlib

    if {$res == "ok"} {
	login $logindata
    } else {
	MessageDlg [epath] -aspect 50000 -icon error \
	    -message [::msgcat::mc "Registration failed: %s" \
				   [error_to_string $xml]] \
	    -type user -buttons ok -default 0 -cancel 0
    }
}

proc client:error {xlib condition message} {
    global reconnect

    if {[winfo exists .client_error]} {
	destroy .client_error
    }

    switch -- $condition {
	bad-format -
	bad-namespace-prefix -
	connection-timeout -
	invalid-from -
	invalid-id -
	invalid-namespace -
	invalid-xml -
	remote-connection-failed -
	restricted-xml -
	unsupported-encoding -
	unsupported-stanza-type -
	xml-not-well-formed {
	    set reconnect($xlib) true
	}
	default {
	    set reconnect($xlib) false
	}
    }

    NonmodalMessageDlg .client_error -aspect 50000 -icon error \
				     -message $message
}

# TODO
proc show_logout_dialog {} {
    global reason reasonlist

    set lw .logout

    if {[winfo exists $lw]} {
	destroy $lw
    }

    Dialog $lw -title [::msgcat::mc "Logout with reason"] \
	    -separator 1 -anchor e -default 0 -cancel 1

    set lf [$lw getframe]
    grid columnconfigure $lf 1 -weight 1

    if {[llength $reasonlist]} {set reason [lindex $reasonlist 0]}

    label $lf.lreason   -text    [::msgcat::mc "Reason:"]
    ecursor_entry [ComboBox $lf.reason -textvariable reason \
	    -values $reasonlist -width 35].e
    label $lf.lpriority -text    [::msgcat::mc "Priority:"]
    ecursor_entry [entry $lf.priority -textvariable loginconf(priority)]

    grid $lf.lreason   -row 0 -column 0 -sticky e
    grid $lf.reason    -row 0 -column 1 -sticky ew
    grid $lf.lpriority -row 1 -column 0 -sticky e
    grid $lf.priority  -row 1 -column 1 -sticky ew

    $lw add -text [::msgcat::mc "Log out"] -command logout_reason
    $lw add -text [::msgcat::mc "Cancel"] -command "$lw withdraw"

    $lw draw $lf.reason
}

proc logout_reason {} {
    global logoutuserstatus logouttextstatus logoutpriority reason reasonlist

    set reasonlist [update_combo_list $reasonlist $reason 10]

    set lw .logout
    if {[winfo exists $lw]} {
	destroy $lw
    }

    # TODO
    set logoutpriority $::loginconf(priority)
    set logouttextstatus $reason
    set logoutuserstatus unavailable

    logout
}

# vim:ts=8:sw=4:sts=4:noet
